home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / prolog.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  5.4 KB  |  128 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         prolog.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  The following is a tiny Prolog interpreter in MacLisp.
  7. ;        It was inspired by other tiny Lisp-based Prologs of
  8. ;        Par Emanuelson and Martin Nilsson.
  9. ;        There are no side-effects anywhere in the implementation.
  10. ;        Though it is VERY slow of course.
  11. ; Author:       Ken Kahn, modified for XLISP by David Betz.
  12. ; Created:      Sat Oct  5 20:58:51 1991
  13. ; Modified:     Sat Oct  5 21:00:01 1991 (Niels Mayer) mayer@hplnpm
  14. ; Language:     Lisp
  15. ; Package:      N/A
  16. ; Status:       X11r5 contrib tape release
  17. ;
  18. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  19. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  20. ;
  21. ; Permission to use, copy, modify, distribute, and sell this software and its
  22. ; documentation for any purpose is hereby granted without fee, provided that
  23. ; the above copyright notice appear in all copies and that both that
  24. ; copyright notice and this permission notice appear in supporting
  25. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  26. ; used in advertising or publicity pertaining to distribution of the software
  27. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  28. ; makes no representations about the suitability of this software for any
  29. ; purpose.  It is provided "as is" without express or implied warranty.
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defun prolog (database &aux goal)
  33.        (do () ((not (progn (princ "Query?") (setq goal (read)))))
  34.               (prove (list (rename-variables goal '(0)))
  35.                      '((bottom-of-environment))
  36.                      database
  37.                      1)))
  38.  
  39. ;; prove - proves the conjunction of the list-of-goals
  40. ;;         in the current environment
  41.  
  42. (defun prove (list-of-goals environment database level)
  43.       (cond ((null list-of-goals) ;; succeeded since there are no goals
  44.              (print-bindings environment environment)
  45.              (not (y-or-n-p "More?")))
  46.             (t (try-each database database
  47.                          (cdr list-of-goals) (car list-of-goals)
  48.                          environment level))))
  49.  
  50. (defun try-each (database-left database goals-left goal environment level 
  51.                  &aux assertion new-enviroment)
  52.        (cond ((null database-left) nil) ;; fail since nothing left in database
  53.              (t (setq assertion
  54.                       (rename-variables (car database-left)
  55.                                         (list level)))
  56.                 (setq new-environment
  57.                       (unify goal (car assertion) environment))
  58.                 (cond ((null new-environment) ;; failed to unify
  59.                        (try-each (cdr database-left) database
  60.                                  goals-left goal
  61.                                  environment level))
  62.                       ((prove (append (cdr assertion) goals-left)
  63.                               new-environment
  64.                               database
  65.                               (+ 1 level)))
  66.                       (t (try-each (cdr database-left) database
  67.                                    goals-left goal
  68.                                    environment level))))))
  69.  
  70. (defun unify (x y environment &aux new-environment)
  71.        (setq x (value x environment))
  72.        (setq y (value y environment))
  73.        (cond ((variable-p x) (cons (list x y) environment))
  74.              ((variable-p y) (cons (list y x) environment))
  75.              ((or (atom x) (atom y))
  76.                   (cond ((equal x y) environment)
  77.                         (t nil)))
  78.              (t (setq new-environment (unify (car x) (car y) environment))
  79.                 (cond (new-environment (unify (cdr x) (cdr y) new-environment))
  80.                   (t nil)))))
  81.  
  82. (defun value (x environment &aux binding)
  83.        (cond ((variable-p x)
  84.               (setq binding (assoc x environment :test #'equal))
  85.               (cond ((null binding) x)
  86.                     (t (value (cadr binding) environment))))
  87.              (t x)))
  88.  
  89. (defun variable-p (x)
  90.        (and x (listp x) (eq (car x) '?)))
  91.  
  92. (defun rename-variables (term list-of-level)
  93.        (cond ((variable-p term) (append term list-of-level))
  94.              ((atom term) term)
  95.              (t (cons (rename-variables (car term) list-of-level)
  96.                       (rename-variables (cdr term) list-of-level)))))
  97.  
  98. (defun print-bindings (environment-left environment)
  99.        (cond ((cdr environment-left)
  100.               (cond ((= 0 (nth 2 (caar environment-left)))
  101.                      (prin1 (cadr (caar environment-left)))
  102.                      (princ " = ")
  103.                      (print (value (caar environment-left) environment))))
  104.               (print-bindings (cdr environment-left) environment))))
  105.  
  106. ;; a sample database:
  107. (setq db '(((father madelyn ernest))
  108.            ((mother madelyn virginia))
  109.        ((father david arnold))
  110.        ((mother david pauline))
  111.        ((father rachel david))
  112.        ((mother rachel madelyn))
  113.            ((grandparent (? grandparent) (? grandchild))
  114.             (parent (? grandparent) (? parent))
  115.             (parent (? parent) (? grandchild)))
  116.            ((parent (? parent) (? child))
  117.             (mother (? parent) (? child)))
  118.            ((parent (? parent) (? child))
  119.             (father (? parent) (? child)))))
  120.  
  121. ;; the following are utilities
  122. (defun y-or-n-p (prompt)
  123.        (princ prompt)
  124.        (eq (read) 'y))
  125.  
  126. ;; start things going
  127. (prolog db)
  128.